home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / gnome-games / aisleriot / games / ten_across.scm < prev    next >
Encoding:
Text File  |  2009-04-14  |  10.1 KB  |  298 lines
  1. ; AisleRiot - ten-across.scm
  2. ;; base on klondike.scm
  3. ; Copyright (C) 1998, 2003 Jonathan Blandford <jrb@mit.edu>
  4. ; Copyright (C) 1999 James LewisMoss <dres@debian.org>
  5. ;
  6. ; This game is free software; you can redistribute it and/or modify
  7. ; it under the terms of the GNU General Public License as published by
  8. ; the Free Software Foundation; either version 2, or (at your option)
  9. ; any later version.
  10. ;
  11. ; This program is distributed in the hope that it will be useful,
  12. ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ; GNU General Public License for more details.
  15. ;
  16. ; You should have received a copy of the GNU General Public License
  17. ; along with this program; if not, write to the Free Software
  18. ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  19. ; USA
  20.  
  21. (define allow-two-spot-use #t)
  22.  
  23. ; The set up:
  24.  
  25. (define tableau '(2 3 4 5 6 7 8 9 10 11))
  26. (define tmp-spots '(0 1))
  27. (define stock 0)
  28.  
  29. (define (new-game)
  30.   (initialize-playing-area)
  31.   (set-ace-low)
  32.   
  33.   (make-standard-deck)
  34.   (shuffle-deck)
  35.   
  36.   (add-blank-slot)
  37.   (add-normal-slot DECK)
  38.   (add-normal-slot '())
  39.   (add-carriage-return-slot)
  40.   (map (lambda (ignore) (add-extended-slot '() down)) tableau)
  41.   (map (lambda (slot)
  42.          (set-slot-y-expansion!
  43.           slot 0.25))
  44.        tableau)
  45.   (deal-ten-across-cards)
  46.  
  47.   (deal-cards-face-up stock '(1))
  48.  
  49.   (flip-top-card stock)
  50.   
  51.   (list 10 4))
  52.  
  53. (define (deal-ten-across-cards)
  54.   (let* ((deal-len (length tableau))
  55.          (direction #t)
  56.          (deal-ten-across-int
  57.           (lambda (num)
  58.             (if direction
  59.                 (begin
  60.                   (deal-cards-face-up stock (list-head tableau num))
  61.                   (deal-cards stock
  62.                               (list-head
  63.                                (list-tail tableau num) (- deal-len num num)))
  64.                   (deal-cards-face-up stock (list-tail tableau (- deal-len num))))
  65.                 (begin
  66.                   (deal-cards-face-up stock
  67.                                       (reverse (list-tail tableau
  68.                                                           (- deal-len num))))
  69.                   (deal-cards stock
  70.                               (reverse (list-head
  71.                                         (list-tail tableau num)
  72.                                         (- deal-len num num))))
  73.                   (deal-cards-face-up stock (reverse (list-head tableau num)))))
  74.             (set! direction (not direction)))))
  75.   (map (lambda (num-now) (deal-ten-across-int num-now)) '(1 2 3 4 5))))
  76.  
  77. ;; testing functions
  78. ;;(define deal-cards (lambda (num slot-list) (map (lambda (num1) (display "dealing face-down to ")(display num1)(display "\n")) slot-list)))
  79. ;;(define deal-cards-face-up (lambda (num slot-list) (map (lambda (num1) (display "dealing face-up to ") (display num1) (display "\n")) slot-list)))
  80. ;;(deal-ten-across-cards)
  81.  
  82. (define (button-pressed slot-id card-list)
  83.   (and (or (> slot-id 1)
  84.            (and (member slot-id tmp-spots)
  85.                 (= (length card-list) 1)))
  86.        (is-visible? (car (reverse card-list)))))
  87.  
  88. (define (complete-transaction start-slot card-list end-slot)
  89.   (move-n-cards! start-slot end-slot card-list)
  90.   (if (and (not (empty-slot? start-slot)) 
  91.            (member start-slot tableau))
  92.       (make-visible-top-card start-slot))
  93.   #t)
  94.  
  95. (define (is-ok-to-place card1 card2)
  96.   (and (= (get-suit card1)
  97.           (get-suit card2))
  98.        (= (get-value card2)
  99.           (+ (get-value card1) 1))))
  100.  
  101. (define (droppable? start-slot card-list end-slot)
  102.   (and (not (= start-slot end-slot))
  103.        (or (and (member end-slot tableau)
  104.                 (if (empty-slot? end-slot)
  105.                     (= king (get-value (car (reverse card-list))))
  106.                     (is-ok-to-place (car (reverse card-list))
  107.                                     (get-top-card end-slot))))
  108.            (and allow-two-spot-use
  109.                 (member end-slot tmp-spots)
  110.                 (= 1 (length card-list))
  111.                 (empty-slot? end-slot)))))
  112.  
  113. (define (button-released start-slot card-list end-slot)
  114.   (and (droppable? start-slot card-list end-slot)
  115.        (complete-transaction start-slot card-list end-slot)))
  116.  
  117. (define (button-clicked start-slot)
  118.   #f)
  119.  
  120. (define (button-double-clicked start-slot)
  121.   ;; uncomment for some debugging output :)
  122. ;;  (display (get-cards 0))
  123. ;;  (newline)
  124. ;;  (display (get-cards 1))
  125. ;;  (newline)
  126. ;;  (display (get-cards 2))
  127. ;;  (newline)
  128. ;;  (display (get-cards 3))
  129. ;;  (newline)
  130. ;;  (display (get-cards 4))
  131. ;;  (newline)
  132. ;;  (display (get-cards 5))
  133. ;;  (newline)
  134. ;;  (display (get-cards 6))
  135. ;;  (newline)
  136. ;;  (display (get-cards 7))
  137. ;;  (newline)
  138. ;;  (display (get-cards 8))
  139. ;;  (newline)
  140. ;;  (display (get-cards 9))
  141. ;;  (newline)
  142. ;;  (display (get-cards 10))
  143. ;;  (newline)
  144. ;;  (display (get-cards 11))
  145. ;;  (newline)
  146.   #f)
  147.  
  148. ;; three things to test for
  149. ;; 1) empty slot and a king not currently in an empty slot
  150. ;; 2) a visible card that will fit on the end of a current row
  151. ;; 3) a single card at the top of a stack either of non-visible cards
  152. ;;    or non-connected cards and an empty temporary spot.
  153.  
  154. ;;----------------------------------------------------------------------
  155. (define (have-empty-slot? slot-list)
  156.   (or-map (lambda (item) (= 0 (length (get-cards item)))) slot-list))
  157.  
  158. (define (king? card)
  159.   (= (get-value card) king))
  160.  
  161. (define (get-good-king-for-empty-move slot-list)
  162.   (or-map (lambda (item)
  163.             (let ((cards1 (get-cards item)))
  164.                    ;; cut out the last card because if it's a king we
  165.                    ;; don't want to move it
  166.               (if (> (length cards1) 0)
  167.                   (or-map (lambda (item) (if (and (is-visible? item)
  168.                                               (king? item))
  169.                                              item
  170.                                          #f))
  171.                       (list-head cards1 (- (length cards1) 1)))
  172.                   #f)))
  173.           slot-list))
  174.  
  175. ;; ** 3 **
  176. (define (test-king-move slot-list)
  177.   (if (have-empty-slot? slot-list)
  178.       (let ((good-king (get-good-king-for-empty-move slot-list)))
  179.         (if (list? good-king)
  180.             (list 2 (get-name good-king) (_"an empty slot"))
  181.             #f))
  182.       #f))
  183.  
  184. ;;----------------------------------------------------------------------
  185. (define (find-card-for item slot-num slot-list)
  186.   (or-map (lambda (slot)
  187.             (or-map (lambda (card)
  188.                       (if (and (not (= slot-num slot))
  189.                                (is-visible? card)
  190.                                (is-ok-to-place card item))
  191.                           (list card item)
  192.                           #f))
  193.                       (get-cards slot)))
  194.           slot-list))
  195.  
  196. ;; ** 2 **
  197. (define (test-stack-move slot-list tmp-list)
  198.   (let ((cards (or-map
  199.                 (lambda (slot)
  200.                   (let ((card-list (get-cards slot)))
  201.                     (if (not (null? card-list))
  202.                         (find-card-for (car card-list) slot slot-list)
  203.                         #f)))
  204.                 slot-list)))
  205.         (if (list? cards)
  206.             (list 2 (get-name (car cards)) (get-name (cadr cards)))
  207.             #f)))
  208.  
  209. ;;----------------------------------------------------------------------
  210. (define (get-top-cards slot-list)
  211.   (map (lambda (slot)
  212.          (let ((cards (get-cards slot)))
  213.            (if (null? cards)
  214.                '()
  215.                (car cards))))
  216.        slot-list))
  217.  
  218. ;; ** 1 **
  219. (define (test-for-tmp-move-down slot-list tmp-list)
  220.   (let* ((move-to-cards (get-top-cards slot-list))
  221.          (move-from-cards (get-top-cards tmp-list))
  222.          (cards (or-map (lambda (card1)
  223.                           (or-map (lambda (card2)
  224.                                     (cond ((and (null? card2)
  225.                                                 (not (null? card1))
  226.                                                 (king? card1))
  227.                                            (list card1 (_"an empty slot")))
  228.                                           ((and (not (null? card1))
  229.                                                 (not (null? card2))
  230.                                                 (is-ok-to-place card1 card2))
  231.                                            (list card1 card2))
  232.                                           (#t #f)))
  233.                                   move-to-cards))
  234.                         move-from-cards)))
  235.     (if (list? cards)
  236.         (list 1
  237.               (get-name (car cards))
  238.               (if (list? (cadr cards))
  239.                   (get-name (cadr cards))
  240.                   (cadr cards)))
  241.         #f)))
  242.  
  243. ;;----------------------------------------------------------------------
  244. (define (get-hint)
  245.   (or
  246.    (test-for-tmp-move-down tableau tmp-spots)
  247.    (test-stack-move tableau tmp-spots) 
  248.    (test-king-move tableau) 
  249.    (and allow-two-spot-use
  250.         (have-empty-slot? tmp-spots)
  251.         (list 0 (_"Move a card to an empty temporary slot")))
  252.    (list 0 (_"No hint available"))))
  253.  
  254. (define final-stack-helper
  255.   (lambda (the-list num suit)
  256.     (if (null? the-list)
  257.         #t
  258.         (let ((card (car the-list))
  259.               (rest (cdr the-list)))
  260.           (if (and (is-visible? card)
  261.                    (= suit (get-suit card))
  262.                    (= num (get-value card)))
  263.               (final-stack-helper rest (+ 1 num) suit)
  264.               #f)))))
  265.  
  266. (define (final-stack? card-list)
  267.     (final-stack-helper card-list 1 (get-suit (car card-list))))
  268.  
  269. (define won-tester
  270.   (lambda (slot-list)
  271.     (let ((to-test (car slot-list))
  272.           (to-cont (cdr slot-list)))
  273.       (if (or (and (= 13 (length (get-cards to-test)))
  274.                    (final-stack? (get-cards to-test)))
  275.               (= 0 (length (get-cards to-test))))
  276.           (if (equal? to-cont '())
  277.               #t
  278.               (won-tester to-cont))
  279.           #f))))
  280.   
  281. (define (game-won)
  282.   (won-tester tableau))
  283.  
  284. (define (game-over)
  285.   (not (game-won)))
  286.  
  287. (define (get-options)
  288.   (list (list (_"Allow temporary spots use") allow-two-spot-use)))
  289.  
  290. (define (apply-options options)
  291.   (set! allow-two-spot-use (cadar options)))
  292.  
  293. (define (timeout) #f)
  294.  
  295. (set-features droppable-feature scores-disabled)
  296.  
  297. (set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won get-hint get-options apply-options timeout droppable?)
  298.